home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / defsys 5.0 / expand-file-name.l < prev    next >
Encoding:
Text File  |  1992-09-02  |  3.9 KB  |  107 lines  |  [TEXT/CCL2]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         expand-file-name.l
  3. ; Description:  expand vars in a file-name-string (Unix or MacIntosh)
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      13-Nov-91
  6. ; Modified:     Tue Aug 11 12:05:46 1992 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      CL-USER
  9. ;;; *************************************************************************
  10. ;;; Copyright (c) 1989, Hewlett-Packard Company
  11. ;;; All rights reserved.
  12. ;;;
  13. ;;; Use and copying of this software and preparation of derivative works
  14. ;;; based upon this software are permitted.  Any distribution of this
  15. ;;; software or derivative works must comply with all applicable United
  16. ;;; States export control laws.
  17. ;;; 
  18. ;;; This software is made available AS IS, and Hewlett-Packard Company
  19. ;;; makes no warranty about the software, its performance or its conformity
  20. ;;; to any specification.
  21. ;;; 
  22. ;;; Suggestions, comments and requests for improvements are welcome
  23. ;;; and should be mailed to laubsch@hplabs.com.
  24. ;;; *************************************************************************
  25.  
  26. (in-package "CL-USER")
  27. (provide "expand-file-name")
  28.  
  29. ;--------------------------------------------------------------------------;
  30. ; expand-file-name
  31. ;-----------------
  32. ; expand UNIX environment-vars in a file-name-string
  33. ; if they are defined
  34.  
  35. #+KCL (defvar *logical-pathnames* ())
  36. #+(or LUCID KCL)
  37. (defun EXPAND-FILE-NAME (FILENAME)
  38.   "Convert FILENAME to absolute. Initial ~ is expanded."
  39.   (declare (optimize (safety 3)))
  40.   (typecase FILENAME
  41.     (string)
  42.     (symbol (setq FILENAME (symbol-name FILENAME)))
  43.     (pathname (setq FILENAME (namestring FILENAME)))
  44.     (t (error "~S should be a string naming a pathname" FILENAME)))
  45.   (flet ((strip-slash (s)
  46.        (let ((ln (length s)))
  47.          (if (char-equal (elt s (1- ln)) #\/)
  48.          (subseq s 0 (1- ln))
  49.            s))))
  50.     (let* ((env0 (position #\$ FILENAME)))
  51.       (if env0
  52.       (let* ((env1 (or (position #\/ FILENAME :start env0)
  53.                (length FILENAME)))
  54.          (vname (subseq FILENAME (1+ env0) env1))
  55.          (value (#+(or ALLEGRO KCL) SYSTEM::getenv
  56.                #+ LUCID           SYSTEM::environment-variable
  57.                #-(or ALLEGRO KCL LUCID) identity
  58.                vname)))
  59.         ;; allow local redefinition via define-logical-pathname
  60.         #+KCL(let ((p (assoc vname *logical-pathnames*
  61.                  :test #'string=)))
  62.            (when p (setq value (cdr p))))
  63.         (if value
  64.         (expand-file-name
  65.          (concatenate 'string
  66.                   (subseq FILENAME 0 env0)
  67.                   (strip-slash value)
  68.                   (subseq FILENAME env1)))
  69.           FILENAME))
  70.     (if (and (> (length FILENAME) 1) (string= "~/" FILENAME :end2 2))
  71.         (concatenate 'string
  72.              (namestring (USER-HOMEDIR-PATHNAME))
  73.              (subseq FILENAME 2))
  74.       FILENAME)))))
  75.  
  76. #+(or CCL MCL)
  77. (defun expand-file-name (FILENAME)
  78.   "Convert FILENAME from Unix Syntax to Mac Syntax, substituting logical directories."
  79.   (declare (optimize (safety 3)))
  80.   (typecase FILENAME
  81.     (string)
  82.     (symbol (setq FILENAME (symbol-name FILENAME)))
  83.     (pathname (setq FILENAME (namestring FILENAME)))
  84.     (t (error "~S should be a string naming a pathname" FILENAME)))
  85.   (flet ((strip-seperator (s)
  86.        (let ((ln (length s)))
  87.          (if (char-equal (elt s (1- ln)) #\/)
  88.                  (subseq s 0 (1- ln))
  89.            s))))
  90.     (setq filename (strip-seperator filename))
  91.     (let* ((env0 (position #\$ FILENAME)))
  92.       (substitute
  93.        #\:
  94.        #\/
  95.        (if env0
  96.            (let ((env1 (position #\/ FILENAME :start env0)))
  97.              (#+MCL identity #-MCL expand-logical-namestring
  98.               (concatenate 'string 
  99.                            (subseq FILENAME (1+ env0) env1)
  100.                            ";"
  101.                            (if env1 (subseq FILENAME (1+ env1)) ""))))
  102.      FILENAME)))))
  103.  
  104. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  105. ;;                          End of expand-file-name.l
  106. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  107.